;;;; -*- Mode: Lisp; Package: :lib.gl; -*-

;;;; gllib.lisp

(in-package :lib.gl)

#-xlui
(eval-when (:compile-toplevel :load-toplevel)
  (do-symbols (s :gl)
    (when (cl-ppcre:scan "^GL.*" (symbol-name s))
      (export s :gl))))

#+cl-who
(defmacro slui (s-expression)
  `(let* ((*read-eval* t)
          (cl-who:*html-empty-tag-aware-p* nil))
     (read-from-string
      (cl-who:with-html-output-to-string
          (s nil :indent t)
        ,s-expression))))
(defun map-lisp-type-to-gl (type)
  (case type
    (double-float :double)
    (single-float :float)))

;; Use aux:with-gensyms
(defmacro with-world-transformation (spatial &body body)
  `(let* ((m (transformation ,spatial))
	  (pv (m* (projection-matrix (camera (view spatial)))
		  (view-matrix (camera (view spatial)))))
	  (world-mvp-matrix (m* pv m)))
     ,@body
     ))

(defmacro with-transform (trns &body body)
  `(progn
     (gl:push-matrix)
     (gl:mult-transpose-matrix (homogeneous-matrix ,trns))
     (unwind-protect (progn ,@body)
       (gl:pop-matrix))))

(defmacro with-model-transformation (spatial &body body)
  `(let* ((m (transformation ,spatial)))
     (gl:push-matrix)
     (gl:mult-transpose-matrix (homogeneous-matrix m))
     (unwind-protect (progn ,@body)
       (gl:pop-matrix))))

;; Not much for the moment, but will eventually involve the use of buffer arrays.
(defmacro with-i-buffer (geometry &body body)
  (declare (ignore geometry))
  `(progn
     ,@body))

;; Likewise, not much until I understand better how I want to implement render states.
(defmacro with-global-states (geometry &body body)
  (declare (ignore geometry))
  `(progn
     ,@body))

(defmacro with-gl (value &body body)
  `(progn (gl:begin ,value)
     ,@body
     (gl:end)))

(defmacro with-gl-enabled (state &body body)
  `(progn (glEnable ,state)
     ,@body
     (glEnd)))

(defmacro with-glcontext (view &body body)
  #-xlui `(progn ,@body)
  #+xlui `(lui::with-glcontext ,view ,@body))

(defmacro ensure-glcontext (&optional ))

;;;; === Vertex Lists ===
;;;; Ala pyglet

(defstruct vertex-list-definition
  name
  format
  attributes
  components
  sizes
  stride
  usage)

(defstruct vertex-list
  array
  mode
  states
  indices)

(defun %array-name-from-format (array-format)
  (let ((name "gl-array-"))
    (iter (for fmt in array-format)
	  (setf name (concatenate 'string name (symbol-name fmt))))
    (intern name (find-package :lib.gl))))

(defun parse-array-type (type-string)
  (case (intern type-string :keyword)
    (:|f| :float)
    (:|d| :double)
    (:|b| :unsigned-char)))

(defun %array-vector-clause (size type)
  (let ((components (%array-vector-components size)))
    `(gl:vertex :type ,type :components ,components)))

(defun %array-vector-components (size)
   (ecase size
     (2 '(x y))
     (3 '(x y z))
     (4 '(x y z w))))

(defun %array-color-clause (size type)
  (let ((components (%array-color-components size)))
    `(gl:color :type ,type :components ,components)))

(defun %array-color-components (size)
  (ecase size
    (3 '(r g b))
    (4 '(r g b a))))

(defun %array-texcoord-clause (size type)
  (let ((components (%array-texcoord-components size)))
    `(gl:tex-coord :type ,type :components ,components)))

(defun %array-texcoord-components (size)
  (ecase size
    (2 '(u v))
    (3 '(u v w))))

(defun %array-normal-clause (size type)
  (let ((components (%array-normal-components size)))
    `(gl:normal :type ,type :components ,components)))

(defun %array-normal-components (size)
  (ecase size
    (2 '(x y))
    (3 '(x y z))))

(defun %gl-array-clause (fmt)
  (let* ((fstring (symbol-name fmt))
	 (class (char fstring 0))
	 (size (parse-integer (string (char fstring 1))))
	 (type (parse-array-type (String (char fstring 2)))))
    (case (intern (string class) :keyword)
      (:|v| (list :vertex-array (%array-vector-components size) (%array-vector-clause size type)))
      (:|c| (list :color-array (%array-color-components size) (%array-color-clause  size type)))
      (:|t| (list :texture-coord-array (%array-texcoord-components size) (%array-texcoord-clause size type)))
      (:|n| (list :normal-array (%array-normal-components size) (%array-normal-clause size type))))))

(defun ensure-array-format (array-format)
  (destructuring-bind (attribs comps clauses) (iter (for spec in array-format)
						    (destructuring-bind (a c cl) (%gl-array-clause spec)
						      (collecting a into an)
						      (collecting c into cn)
						      (collecting cl into cln))
						    (finally (return (list an cn cln))))
    (values (%array-name-from-format array-format)
	    attribs
	    comps
	    clauses)))

(defun determine-attribute-sizes (array-format)
  (iter (for fmt in array-format)
	(collecting (parse-integer (string (char (symbol-name fmt) 1))))))

(defun calculate-attribute-stride (array-format)
  (iter (for fmt in array-format)
	(summing (let ((size (parse-integer (string (char (symbol-name fmt) 1))))
		       (type (parse-array-type (string (char (symbol-name fmt) 2)))))
		   (* size (gl::foreign-type-size type))))))

(defparameter *vertex-list-definitions* (make-hash-table))

(defun get-vlist-definition (fmt)
  (gethash fmt *vertex-list-definitions*))

(defun vlist-constructor-name (vld)
  (intern (format nil "%new-~A" (vertex-list-definition-name vld)) (find-package :lib.gl)))

(defun set-vlist-definition (fmt def)
  (setf (gethash fmt *vertex-list-definitions*) def))

(defun %load-gl-array-values (glarray components values)
  (flet ((set-components (i components v)
	   ;(format t "~A~%" v)
	   (if components
	       (iter (for c in components)
		     (for j from 0)
		     (setf (gl:glaref glarray i c) (if (typep v 'array)
						       (aref v i j)
						       (nth j v))))
	       (setf (gl:glaref glarray i) v))))
    (typecase values
      (vector (iter (for v in-vector values)
		    (for i below (length values)) ;(vector-length values)
		    (set-components i nil v)))
      (array (iter (for i below (array-dimension values 0))
		   (set-components i components values)))
      (cons  (iter (for v in values)
		   (for i from 0)
		   (set-components i components v))))
    glarray))

(defmacro define-vertex-list (&rest array-format)
  (alexandria:with-gensyms (vlist-def attributes size indices mode new-array new-index-array)  
    (multiple-value-bind (name attribute-names components clauses) (ensure-array-format array-format)
      (let ((constructor (intern (format nil "%new-~A" name))))
	`(let ((,vlist-def (make-vertex-list-definition :name ',name
							:format ',array-format
							:attributes ',attribute-names
							:components ',components
							:sizes (determine-attribute-sizes ',array-format)
							:stride (calculate-attribute-stride ',array-format))))
	   (gl:define-gl-array-format ,name ,@clauses)
	   (set-vlist-definition ',name ,vlist-def)
	   (defun ,constructor (,attributes ,size ,indices ,mode)
	     (let ((,new-array (gl:alloc-gl-array ',name ,size))
		   (,new-index-array (%load-gl-array-values 
				     (gl:alloc-gl-array :unsigned-short (length ,indices))
				     nil ,indices)))
	       (mapcar #'(lambda (a c)
			   (%load-gl-array-values ,new-array a c))
		       ',components
		       ,attributes)
	       (make-vertex-list :array ,new-array
				 :mode ,mode
				 :states ',attribute-names
				 :indices ,new-index-array))))))))

;;(define-vertex-list |v3f| |c3f|)

(defun new-vertex-list (&key format data (indices nil) mode)
  "Create a VAO from argument list of alternating attribute definitions and attribute data."
  (let* ((name (%array-name-from-format format))
	 (data-count (if (typep (first data) 'array)
			 (array-dimension (first data) 0)
			 (length (first data))))
	 (vldef (get-vlist-definition name)))
    (unless vldef
      (error "No gl-array defined for format ~A." format))
    ;; Found the gl-array definition, let's load the data
    (funcall (vlist-constructor-name vldef) data data-count indices mode)))

(defun delete-vertex-list (vlist)
  (gl:free-gl-array (vertex-list-array vlist))
  (gl:free-gl-array (vertex-list-indices vlist)))

(defun draw-vertex-list (vlist)
  (dolist (state (vertex-list-states vlist))
    (gl:enable-client-state state))
  (gl:bind-gl-vertex-array (vertex-list-array vlist))
  (gl:draw-elements (vertex-list-mode vlist) (vertex-list-indices vlist))
  (dolist (state (vertex-list-states vlist))
    (gl:disable-client-state state)))

;;;; Buffer Objects ==
;;; I am not happy with dthis current implementation!

;; (defstruct glbuf
;;   id
;;   target
;;   type
;;   usage) ;; Add slot for glcontext?

;; (defun enable-buffer (glbuffer)
;;   (gl:bind-buffer (glb uf-target glbuffer) (glbuf-id glbuffer)))

;; (defun disable-buffer (glbuffer)
;;   (gl:bind-buffer (glbuf-target glbuffer) 0))

;; (defmacro with-glbuffer (glbuffer &body body)
;;   `(unwind-protect
;; 	(progn
;; 	  (enable-buffer ,glbuffer)
;; 	  ,@body)
;;      (disable-buffer ,glbuffer)))


;; (defun set-glbuffer-data (buf data)
;;   (gl:push-client-attrib :client-vertex-array-bit)
;;   (gl:bind-buffer (glbuf-target buf) (glbuf-id buf)) 
;;   (gl:buffer-data (glbuf-target buf) (glbuf-usage buf) (ensure-gl-buffer-data data))
;;   )
;; ;; Reject multi-dimensional arrays?
;; (defun array-from-arrays (array-list)
;;   (let* ((total-size (iter (for arr in array-list)
;; 			   (summing (array-total-size arr))))
;; 	 (atype (if (eql (array-element-type (first array-list)) t)
;; 		    'single-float
;; 		    (array-element-type (first array-list))))
;; 	 (total-array (make-array total-size 
;; 				  :element-type atype))
;; 	 (idx 0))
;;     (dolist (a array-list total-array)
;;       (dotimes (i (array-total-size a))
;; 	(setf (aref total-array idx) (row-major-aref a i))
;; 	(incf idx)))))

;; (defun new-buffer (data &key (target :array-buffer) (usage :static-draw))
;;   "Must be called within an active GL context!"
;;   (if (listp data)
;; 	(setq data (array-from-arrays data)))
;;   (let* ((atype (array-element-type data))
;; 	 (ftype (case atype
;; 		  (double-float :double)
;; 		  (single-float :float)
;; 		  (t :float))))
;;     (let ((buf (make-glbuf :id (car (gl:gen-buffers 1))
;; 			   :target target
;; 			   :type ftype
;; 			   :usage usage
;; 			   :data data)))
    
;;       (with-glbuffer buf
;; 	(ccl:with-pointer-to-ivector (ptr data)
;; 	  (let ((data (gl::make-gl-array-from-pointer ptr ftype (length data))))
;; 	    (gl:buffer-data (glbuf-target buf) (glbuf-usage buf) data))
;; 	  buf)))))

;; ;;; API for Vertex Attribute Objects (VAO's)
;; ;;; 
;; ; /macro/ defvao (<name> &rest <attribute-defs>) - On calling defines the following
;; ; /defun/ new-vao-<name> (<attribute-data>) - Like make- from defstructs? Returns VAO created by glGenVertexArrays.
;; ; /defun/ update-vao-<name> (<vao> <attribute-data>)
;; ; /defun/ delete-vao-<name> 

;; (defstruct vao
;;   id
;;   glbuf
;;   attributes)


;; (defmacro with-vao (vao &body body)
;;   `(unwind-protect (progn
;; 		     (gl:bind-vertex-array (vao-id ,vao))
;; 		     ,@body)
;;      (gl:bind-vertex-array 0)))

;; (defun new-vao (data attributes)
;;   (let* ((buffer (new-buffer data))
;; 	 (vao (make-vao :id (gl:gen-vertex-array)
;; 			:glbuf buffer
;; 			:attributes attributes))
;; 	 (offset 0))
;;     (with-vao vao
;;       (with-glbuffer buffer
;; 	(iter (for d in data)
;; 	      (for (nil elem-count) in attributes)
;; 	      (for i from 0)
;; 	      (gl:enable-vertex-attrib-array i)
;; 	      (gl:vertex-attrib-pointer i elem-count (glbuf-type buffer) nil 0 (cffi:make-pointer offset))
;; 	      (incf offset (* (array-total-size d) (gl::foreign-type-size (glbuf-type buffer))))
;; 	      (finally vao))))))

;; #|
;; (defvao vertex-colors
;;     pos
;;   color) ==>


;; (defun new-vao-vertex-colors (&key pos color)
;;   (let ((vao (gl:gen-vertex-arrays 1)))
;;     (gl:bind-vertex-array vao)
;;     (let ((vao-buf (gl:gen-buffers 1)))
;;       (gl:bind-buffer vao-buf)
;;       ;; pos and color need to be changed into gl:gl-arrays!
;;       (with-opengl-array (gl-pos pos)
;;         (with-opengl-array (gl-color color)
;;           (gl:buffer-data :gl-array-buffer :static-draw (cffi:null-pointer) :size (+ (gl::gl-array-byte-size pos) 
;;                                                                                      (gl::gl-array-byte-size color)))
;;           (gl:buffer-sub-data :gl-array-buffer gl-pos :buffer-offset 0) 
;;           (gl:buffer-sub-data :gl-array-buffer gl-color :buffer-offset (gl::gl-array-byte-size color))
;;           (gl:vertex-attrib-pointer 0 4 '%gl:float :false 0 (cffi:null-pointer))
;;           (gl:vertex-attrib-pointer 1 4 '%gl:float :false 0 (cffi:make-pointer (gl::gl-array-byte-size pos)))))
;;       (make-vertex-object :vao vao :buffer vao-buf))))
;; |#

;; The cl-opengl version only returns a pointer, I just wanted to save
;; myself the work of creating gl-array structs...
#+ccl
(defmacro with-opengl-array ((var type lisp-array) &body body)
  (check-type var symbol)
  (alexandria:with-unique-names (data ptr)
    `(ccl:with-pointer-to-ivector (,ptr ,lisp-array)
       (let ((,data (gl::make-gl-array-from-pointer ,ptr ,type (array-total-size ,lisp-array))))
	 ,@body))))

(defparameter *matrix-mode* :modelview)
(defmacro with-matrix-mode (mode &body body)
  `(unwind-protect
       (let ((*matrix-mode* ,mode))
	 (gl:matrix-mode *matrix-mode*)
	 ,@body)
     (gl:matrix-mode *matrix-mode*)))

#|
#+xlui
(defun window-to-gl-coord (view win-x win-y &optional (return-single-floats nil))
  (ccl:rlet ((modelview (:array #>GLdouble 16))
             (projection (:array #>GLdouble 16))
             (viewport (:array #>GLint 4))
             (win-z #>GLfloat)
             (pos-x #>GLdouble)
             (pos-y #>GLdouble)
             (pos-z #>GLdouble))
    (with-glcontext view
      (glgetdoublev gl_projection_matrix projection)
      (glgetdoublev gl_modelview_matrix modelview)
      (glgetintegerv gl_viewport viewport)
      (glreadpixels (coerce win-x 'integer) (coerce win-y 'integer)
			   1 1 gl_depth_component gl_float win-z)
      (let ((win-y (- (ccl:paref viewport (:* #>GLint) 3) win-y))
	    (win-z (ccl:%get-single-float win-z)))
	(gluunproject (coerce win-x 'double-float) (coerce win-y 'double-float) (coerce win-z 'double-float) modelview projection viewport pos-x pos-y pos-z)
	(if return-single-floats
	    (values (coerce (ccl:%get-double-float pos-x) 'single-float)
		    (coerce (ccl:%get-double-float pos-y) 'single-float)
		    (coerce (ccl:%get-double-float pos-z) 'single-float))
	    (values (ccl:%get-double-float pos-x) (ccl:%get-double-float pos-y) (ccl:%get-double-float pos-z)))))))
|#

;;;; ---- ;;;;

(defun test-vertex-array ()
  (assert (eql (%array-name-from-format '(:|v2f| :|c3B|))
	       '|gl-array-v2fc3B|))
  (assert (and (eql (parse-array-type "f") :float)
	       (eql (parse-array-type "d") :double)
	       (eql (parse-array-type "B") :unsigned-char)))
  (assert (eql (%gl-array-clause :|v3f|) '(vertex :type :float :components (x y Z))))
  (assert (eql (%gl-array-clause :|t2d|) '(gl:vertex :type :double :components (u v)))))

